structure DiGraph :> DIGRAPH =
struct
  structure Node =
  struct
    datatype 'a t =
      T of {successors : 'a t list ref,
            plist : PropertyList.t}
            
    fun 'a new () =
        T {successors = ref [],
           plist = PropertyList.new ()}
    
    fun addSuccessor (T {successors, ...}, to) =
        successors := to :: (!successors)
             
    fun equals (T {plist = p1, ...}, T {plist = p2, ...}) =
        PropertyList.equals (p1, p2)
        
    fun equalsList (lx, ly) =
        case (lx, ly)
         of ([], []) => true
          | (x :: xs, _) =>
            if List.exists (fn y => equals (x, y)) ly
            then equalsList (xs, List.filter (fn y => if equals (x, y)
                                                      then false
                                                      else true)
                                              ly)
            else false
          | _ => false
        
    fun compare (x1, x2) =
        if equals (x1, x2)
        then EQUAL
        else LESS
    
    fun hasEdge (T {successors, ...}, to) =
        List.exists (fn x => equals (x, to)) (!successors)
        
    fun plist (T {plist, ...}) = plist
    
    fun successors (T {successors, ...}) = !successors
    
    fun junk _ = "junk"
    
  end
  
  datatype 'a t =
    T of {nodes : 'a Node.t list ref}     
  
  fun addNode (T {nodes, ...}, n) =
      nodes := n :: (!nodes)
      

  fun new () = T {nodes = ref []}
  
  fun newNode (T {nodes, ...}) =
      let val n = Node.new ()
          val _ = nodes := n :: (!nodes)
      in  n
      end     
  
  fun hasEdge (g, {from, to}) =
      let val succs = Node.successors from          
      in  List.exists (fn y => Node.equals (to, y)) succs
      end
      
  fun deleteAllEdges (T {nodes, ...}) =
      let fun delete (Node.T {successors, ...}) = 
              successors := []
      in  List.app delete (!nodes)
      end
   
  fun nodes (T {nodes, ...}) = !nodes
   
  fun foreachNode (T {nodes, ...}, f) =
      List.app f (!nodes)
  
  fun predecessors (g, n) =
      let val all = ref []
          val nodes = nodes g
          fun loop l =
              case l
               of [] => ()
                | x :: xs =>
                  let val succs = Node.successors x
                      val _ = if List.exists (fn y => Node.equals (n, y)) succs
                              then all := x :: (!all)
                              else ()
                  in  loop xs
                  end
          val _ = loop nodes
      in  !all
      end
      
  fun removeDuplicatedNodes l =
      case l
       of [] => []
        | x :: xs =>
          if List.exists (fn y => Node.equals (x, y)) xs
          then removeDuplicatedNodes xs
          else x :: (removeDuplicatedNodes xs)
          
  fun intersectionList (l1, l2) =
      case (l1, l2)
       of ([], _) => []
        | (_, []) => []
        | (x :: xs, _) =>
          if List.exists (fn y => Node.equals (x, y)) l2
          then x :: intersectionList (xs, l2)
          else intersectionList (xs, l2)
          
  fun intersectionLists ls =
      case ls
       of [] => []
        | [x] => x
        | x :: y :: xs =>
          intersectionLists (intersectionList (x, y) :: xs)
  
  fun unionList (l1, l2) =
      removeDuplicatedNodes (l1 @ l2)
      
  fun unionLists ls =
      case ls
       of [] => []
        | [x] => x
        | x :: y :: xs =>
          unionLists (unionList (x, y) :: xs)
          
  fun differenceList (l1, l2) =
      case l1
       of [] => []
        | x :: xs =>
          if List.exists (fn y => Node.equals (x, y)) l2
          then differenceList (xs, l2)
          else x :: differenceList (xs, l2)
  
  val tag = false
  fun debugPrint s =
      if tag
      then print s
      else ()        
   
                 
  fun dominatorTree (g, n, convert, debugIt) =
      let fun printList l =
              case l
               of [] => debugPrint "\n"
                | x :: xs =>
                  let val s = debugIt x
                      val _ = debugPrint (String.concat [s, " "])
                  in  printList xs
                  end
          fun printAll (x, l, hints) =
              let val _ = debugPrint (String.concat ["\nthe ", hints, " of "])
                  val _ = printList [x]
                  val _ = debugPrint "is:\n"
                  val _ = printList l
              in  ()
              end
          val {get = pred, set = setPred, destroy = destroyPred, ...} =
              Property.destGetSet (Node.plist, Property.initConst [])
          val nodes = nodes g          
          val {get = dom, set = setDom, destroy = destroyDom, ...} =
              Property.destGetSet (Node.plist, Property.initConst [])
          val _ = setDom (n, [n])
          fun initAllDom ns =
              case ns
               of [] => ()
                | x :: xs =>
                  if Node.equals (x, n)
                  then initAllDom xs
                  else (setDom (x, nodes); initAllDom xs)
          val _ = initAllDom nodes
          fun checkInitDom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val doms = dom x
                      val _ = printAll (x, doms, "initDoms")
                  in  checkInitDom xs
                  end
          val _ = checkInitDom nodes
          fun addPred n =
              let val succs = Node.successors n
                  val _ = printAll (n, succs, "succs")
                  fun doit l =
                      case l
                       of [] => ()
                        | x :: xs =>
                          let val oldPred = pred x
                              val _ = setPred (x, n :: oldPred)
                          in  doit xs
                          end
              in  doit succs
              end
          val _ = foreachNode (g, addPred)
          fun checkPred nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val preds = pred x
                      val _ = printAll (x, preds, "preds")
                  in  checkPred xs
                  end
          val _ = checkPred nodes
          val hasChangedDom = ref false
          fun calculateDom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val preds = pred x
                      val domOfPreds = List.map dom preds
                      val intersection = intersectionLists domOfPreds
                      val all = unionList ([x], intersection)
                      val _ = if Node.equalsList (all, dom x)
                              then ()
                              else (hasChangedDom := true;
                                    setDom (x, all))
                  in  calculateDom xs
                  end
          fun loopCalculateDom nodes =
              let val _ = calculateDom nodes
              in  if !hasChangedDom
                  then (hasChangedDom := false; loopCalculateDom nodes)
                  else ()
              end
          val _ = loopCalculateDom nodes
          fun checkDom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val doms = dom x
                      val _ = printAll (x, doms, "dominators")
                  in  checkDom xs
                  end
          val _ = checkDom nodes
          val {get = sdom, set = setSdom, destroy = destroySdom, ...} =
              Property.destGetSet (Node.plist, Property.initConst [])
          fun setInitSdom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val dom = dom x
                      val _ = setSdom (x, (differenceList (dom, [x])))
                  in  setInitSdom xs
                  end
          val _ = setInitSdom nodes
          val {get = idom, set = setIdom, destroy = destroyIdom, ...} =
              Property.destGetSet (Node.plist, Property.initConst [])
          fun setInitIdom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val sdom = sdom x
                      val _ = printAll (x, sdom, "sdom")
                      val _ = setIdom (x, (differenceList (sdom, [x])))
                  in  setInitIdom xs
                  end
          val _ = setInitIdom nodes
          fun checkInitIdom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val idoms = idom x
                      val _ = printAll (x, idoms, "initIdoms")
                  in  checkInitIdom xs
                  end
          val _ = checkInitIdom nodes
          val hasChangedIdom = ref false
          fun calculateIdom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val idoms = idom x
                      val sdomOfIdoms = List.map sdom idoms
                      val union = unionLists sdomOfIdoms
                      val all = differenceList (idoms, union)
                      val _ = if Node.equalsList (all, idoms)
                              then ()
                              else (hasChangedIdom := true;
                                    setIdom (x, all))
                  in  calculateIdom xs
                  end
          fun loopCalculateIdom nodes =
              let val _ = calculateIdom nodes
              in  if !hasChangedIdom
                  then (hasChangedIdom := false; loopCalculateIdom nodes)
                  else ()
              end
          val _ = loopCalculateIdom nodes
          fun checkIdom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val idoms = idom x
                      val _ = printAll (x, idoms, "idoms")
                  in  checkIdom xs
                  end
          val _ = checkIdom nodes
          val tree = Tree.new ()
          fun checkIdomCorrect l =
              case l
               of [] => NONE
                | [x] => SOME x
                | _ =>
                  let val s = Int.toString (List.length l)
                      val _ = print s
                      val _ = print "\nerror here\n"
                  in  raise Fail "compiler bug\n"
                  end
          val memoize = ref []
          (*fun hasBeenAdd x = List.exists (fn y => Node.equals (#1 x, #1 y)) (!memoize)*)
          fun addMemoize (x, t) = memoize := (x, t) :: (!memoize)
          fun lookup e =
              let fun doit l =
                  case l
                   of [] => raise Fail "compiler bug"
                    | (x, t) :: xs =>
                      if Node.equals (e, x)
                      then t
                      else doit xs
              in  doit (!memoize)
              end
          fun addNodes nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val value = convert x
                      val newNode = Tree.Node.new value
                      val _ = Tree.addNode (tree, newNode)
                      val _ = addMemoize (x, newNode)
                  in  addNodes xs
                  end
          val _ = addNodes nodes
          (*
          fun addEdge nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val treeNodeForX =
                          case lookup x
                           of NONE =>
                              let val new = Tree.Node.new (convert x)
                                  val _ = addMemoize (x, new)
                              in  new
                              end
                            | SOME t => t
                      val idom = idom x
                      val idom = checkIdomCorrect idom
                      val _ = case idom
                               of NONE => ()
                                | SOME idom =>
                                  let val treeNodeForIdom =
                                          case lookup idom
                                           of NONE =>
                                              let val new = Tree.Node.new (convert idom)
                                                  val _ = addMemoize (idom, new)
                                              in  new
                                              end
                                            | SOME t => t
                      	              val _ = Tree.addNode (tree, treeNodeForX)
                                      val _ = Tree.addNode (tree, treeNodeForIdom)
                                      val _ = Tree.addEdge (tree, {from = treeNodeForIdom, to = treeNodeForX})
                                  in ()
                                  end
                  in  addEdge xs
                  end
          *)
          fun addEdges nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val idom = idom x
                      val idom = checkIdomCorrect idom
                      val _ = case idom
                               of NONE => ()
                                | SOME t => Tree.addEdge (tree, {from = lookup t, to = lookup x})
                  in  addEdges xs
                  end
          val _ = addEdges nodes
      in  tree
      end
      
  fun calculateDf (g, n, df, setDf, debugIt) =
      let fun printList l =
              case l
               of [] => debugPrint "\n"
                | x :: xs =>
                  let val s = debugIt x
                      val _ = debugPrint (String.concat [s, " "])
                  in  printList xs
                  end
          fun printAll (x, l, hints) =
              let val _ = debugPrint (String.concat ["\nthe ", hints, " of "])
                  val _ = printList [x]
                  val _ = debugPrint "is:\n"
                  val _ = printList l
              in  ()
              end
          val {get = pred, set = setPred, destroy = destroyPred, ...} =
              Property.destGetSet (Node.plist, Property.initConst [])
          val nodes = nodes g          
          val {get = dom, set = setDom, destroy = destroyDom, ...} =
              Property.destGetSet (Node.plist, Property.initConst [])
          val _ = setDom (n, [n])
          fun initAllDom ns =
              case ns
               of [] => ()
                | x :: xs =>
                  if Node.equals (x, n)
                  then initAllDom xs
                  else (setDom (x, nodes); initAllDom xs)
          val _ = initAllDom nodes
          fun checkInitDom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val doms = dom x
                      val _ = printAll (x, doms, "initDoms")
                  in  checkInitDom xs
                  end
          val _ = checkInitDom nodes
          fun addPred n =
              let val succs = Node.successors n
                  val _ = printAll (n, succs, "succs")
                  fun doit l =
                      case l
                       of [] => ()
                        | x :: xs =>
                          let val oldPred = pred x
                              val _ = setPred (x, n :: oldPred)
                          in  doit xs
                          end
              in  doit succs
              end
          val _ = foreachNode (g, addPred)
          fun checkPred nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val preds = pred x
                      val _ = printAll (x, preds, "preds")
                  in  checkPred xs
                  end
          val _ = checkPred nodes
          val hasChangedDom = ref false
          fun calculateDom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val preds = pred x
                      val domOfPreds = List.map dom preds
                      val intersection = intersectionLists domOfPreds
                      val all = unionList ([x], intersection)
                      val _ = if Node.equalsList (all, dom x)
                              then ()
                              else (hasChangedDom := true;
                                    setDom (x, all))
                  in  calculateDom xs
                  end
          fun loopCalculateDom nodes =
              let val _ = calculateDom nodes
              in  if !hasChangedDom
                  then let val _ = hasChangedDom := false
                           val _ = debugPrint "calculating dominators again\n"
                           val new = loopCalculateDom nodes
                       in  ()
                       end
                  else ()
              end
          val _ = loopCalculateDom nodes
          fun checkDom nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val doms = dom x
                      val _ = printAll (x, doms, "dominators")
                  in  checkDom xs
                  end
          val _ = checkDom nodes
          val {get = dominated, set = setDominated, destroy = destroyDominated, ...} =
              Property.destGetSet (Node.plist, Property.initConst [])
          fun addDominated n =
              let val dom = dom n
                  val _ = printAll (n, dom, "init doms")
                  fun doit l =
                      case l
                       of [] => ()
                        | x :: xs =>
                          let val oldDominated = dominated x
                              val _ = setDominated (x, n :: oldDominated)
                          in  doit xs
                          end
              in  doit dom
              end
          val _ = foreachNode (g, addDominated)
          fun checkDominated nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val dominated = dominated x
                      val _ = printAll (x, dominated, "dominated")
                  in  checkDominated xs
                  end
          val _ = checkDominated nodes
          fun calculate n =
              let val dominated = dominated n
                  val succss = List.map (Node.successors) dominated
                  val alls = unionLists succss
                  val subDominated = differenceList (dominated, [n])
                  val all = differenceList (alls, subDominated)
                  val _ = setDf (n, all)
              in  ()
              end
          val _ = foreachNode (g, calculate)
          fun checkDf nodes =
              case nodes
               of [] => ()
                | x :: xs =>
                  let val df = df x
                      val _ = printAll (x, df, "df")
                  in  checkDf xs
                  end
          val _ = checkDf nodes
          val _ = debugPrint "to here: after df\n"
      in  ()
      end
      
  fun dfs (g, n, f) =
      let val {get = visited, set = setVisited, destroy = destroyVisited, ...} =
              Property.destGetSetOnce (Node.plist, Property.initConst false)
          val {get = start, set = setStart, destroy = destroyStart, ...} =
              Property.destGetSetOnce (Node.plist, Property.initConst 0)
          val {get = finish, set = setFinish, destroy = destroyFinish, ...} =
              Property.destGetSetOnce (Node.plist, Property.initConst 0)
          val destroy = fn _ => (destroyVisited (); destroyStart (); destroyFinish ())
          val times = ref 0
          val inc = fn _ => times := (!times) + 1
          val output = fn n => (f n; print "\n")
          val println = fn _ => print "\n"
          val successor = Node.successors n
          fun dfsNode n =
              let fun loop (p, nodes) =
                      case nodes
                       of [] => ()
                        | x :: xs =>
                          if visited x
                          then loop (p, xs)
                          else (dfsNode x; loop (p, xs))
              in  setVisited (n, true);
                  inc ();
                  setStart (n, !times);
                  output n;
                  print ("start time for ");
                  (output n);
                  print ("is:\n");
                  (print o Int.toString) (start n);
                  println ();
                  loop (n, Node.successors n);
                  inc ();
                  setFinish (n, !times);
                  print ("finish time for ");
                  (output n);
                  print ("is:\n");             
                  (print o Int.toString) (finish n);
                  println ()
              end
      in  dfsNode n;
          destroy ()
      end
      
  fun reachable (g, start) =
      let val {get = visited, set = setVisited, destroy = destroyVisited, ...} =
              Property.destGetSetOnce (Node.plist, Property.initConst false)
          val r = ref []
          fun add x = r := x :: (!r)
          val destroy = fn _ => (destroyVisited ())
          fun dfsNode n =
              let fun loop (p, nodes) =
                      case nodes
                       of [] => ()
                        | x :: xs =>
                          if visited x
                          then loop (p, xs)
                          else (dfsNode x; loop (p, xs))
              in  setVisited (n, true);
                  add n;
                  loop (n, Node.successors n)
              end
      in  dfsNode start;
          destroy ();
          !r
      end
      
  fun toDot (g, name, convert) =
      let fun trans (T {nodes, ...}) =
              let val glist = !nodes
                  fun cookSuccs l =
                      case l
                       of [] => []
                        | node :: xs =>
                          let val succs = Node.successors node
                              fun cook (h, l) =
                                  case l
                                   of [] => []
                                    | x :: xs =>
                                      let val nodex = ()                                     
                                      in  {head = convert h, tail = convert x}
                                          :: (cook (h, xs))                                      
                                      end
                              val one = cook (node, succs)
                              val res = cookSuccs xs
                          in  (one @ res)
                          end
                  val contents = Dot.Content.T (cookSuccs glist)
              in  Dot.T {name = name,
                         size = {width = 10, height = 10},
                         node = {color = "lightblue2", style ="filled"},
                         contents = contents}
              end 
          val dot = trans g
      in  Dot.outputFile (dot)
      end
         
  fun addEdge (g as T {nodes, ...}, {from, to}) =
      (*if hasEdge (g, {from = from, to = to})
      then raise Fail "has already this edge\n"
      else*) let val _ = 
                   case (List.find (fn x => Node.equals (x, from)) (!nodes),
                         List.find (fn x => Node.equals (x, to)) (!nodes))
                    of (NONE, NONE) =>
                       let val _ = addNode (g, from)
                           val _ = addNode (g, to)
                       in  addEdge (g, {from = from, to = to})
                       end
                     | (NONE, _) =>
                       let val _ = addNode (g, from)
                       in  addEdge (g, {from = from, to = to})
                       end
                     | (_, NONE) =>
                       let val _ = addNode (g, to)
                       in  addEdge (g, {from = from, to = to})
                       end
                     | (SOME n, _) =>
                       let val _ =  Node.addSuccessor (from, to)
                       in  ()
                       end
           in  ()
           end
           
  fun dfsTree (g, n, f) =
      let val {get = visited, set = setVisited, destroy = destroyVisited, ...} =
              Property.destGetSetOnce (Node.plist, Property.initConst false)
          val destroy = fn _ => (destroyVisited ())
          val tree = Tree.new ()
          fun dfsNode (n, treeNodeForN) =
              let fun loop (nodes, treeNode) =
                      case nodes
                       of [] => ()
                        | x :: xs =>
                          if visited x
                          then loop (xs, treeNodeForN)
                          else let val treeNodeForX = Tree.Node.new (f x)
                                   val _ = Tree.addNode (tree, treeNodeForX)
                                   val _ = Tree.addEdge (tree, {from = treeNodeForN,
                                                                to = treeNodeForX})
                               in  dfsNode (x, treeNodeForX); loop (xs, treeNodeForN)
                               end
              in  setVisited (n, true);
                  loop (Node.successors n, treeNodeForN)
              end
          val value = f n
          val treeNodeForN = Tree.Node.new value
          val _ = Tree.addNode (tree, treeNodeForN)
      in  dfsNode (n, treeNodeForN);                   
          destroy ();
          tree
      end
      
  fun reverse (g : 'a t, f : 'a Node.t -> 'b, compare : 'b * 'b -> bool, debug) =
      let val {get = label, set = setLabel, destroy = destroyLabel, ...} :
              {get : 'b Node.t -> 'b option, set : 'b Node.t * 'b option -> unit,
               destroy : unit -> unit} =
              Property.destGetSet (Node.plist, Property.initConst NONE)
          val initNodes = nodes g
          val pp = debugPrint o Int.toString o List.length
          val _ = pp initNodes
          val targetGraph : 'b t = new ()
          fun loop l =
              case l
               of [] => ()
                | x :: xs =>
                  let val new = newNode targetGraph
                      val _ = debugPrint (debug x)
                      val name = f x
                      val _ = setLabel (new, SOME name)
                  in  loop xs
                  end
          val _ = loop initNodes
          val _ = debugPrint "after adding nodes\n"
          fun lookup x =
              let val nodes = nodes targetGraph
                  fun loop l =
                      case l
                       of [] => raise Fail "compiler bug"
                        | y :: ys =>
                          case label y
                           of NONE => raise Fail "compiler bug"
                            | SOME yy =>
                              if compare (x, yy)
                              then y
                              else loop ys
              in  loop nodes
              end              
          fun loopAddEdge l =
              case l
               of [] => ()
                | x :: xs =>
                  let val succs = Node.successors x
                      val to = f x
                      val to = lookup to
                      fun add (m : 'a Node.t list) =
                          case m
                           of [] => ()
                            | y :: ys =>
                              let val from = f y
                                  val from = lookup from
                                  val _ = addEdge (targetGraph, {from = from, to = to})
                              in  add ys
                              end
                      val _ = add succs
                  in  loopAddEdge xs
                  end
          val _ = loopAddEdge initNodes
          val _ = debugPrint "after adding edges\n"
      in  {graph = targetGraph, getLabel = fn x => case label x
                                                    of NONE => raise Fail "compiler bug"
                                                     | SOME xx => xx}
      end  
  
  fun numNodes (T {nodes, ...}) = List.length (!nodes)
  
  fun lookup (g, pred) =
      let val nodes = nodes g
          fun loop l =
              case l
               of [] => raise Fail "compiler bug"
                | x :: xs =>
                  if pred x
                  then x
                  else loop xs
      in  loop nodes
      end
end